Power Programmierung/Power-Programmierung (Tewi)(1994).iso/magazine/drdobbs/1987/12/tracy/tracy.lst

File List | 1987-11-13 | 14KB | 209 lines

( LOAD screen for DDJ Standard Prelude and String Extension)
( MJT  Aug 30 1987 for DDJ December 1987)

(     2 LOAD ( Standard prelude)
      3 LOAD ( Augmented interpretation)
   4  5 THRU ( Controlled words)
   6 13 THRU ( Strings)









( FORTH-83 functions-- typical definitions)
( Adjust these words for your Forth.    See DDJ Oct 1987.)
( Note: functions already provided need not be redefined.)
: RECURSE   [COMPILE] MYSELF ;  IMMEDIATE
: INTERPRET   INTERPRET ;

: I> ( - 'data)   COMPILE R> ;  IMMEDIATE
: >I ( - 'data)   COMPILE >R ;  IMMEDIATE

( Used for alignment: )
: ALIGN    ( HERE 1 AND ALLOT) ;
: REALIGN  ( a - a' )  ( DUP 1 AND +) ;

2 CONSTANT CELL   : CELL+   2+ ;    : CELLS   2* ;

: UNDO   I> R> R> 2DROP >I ;  \ Undoes a DO-- LOOP.
( Required definitions - used to support further compilation)

: THRU ( n n2)   1+ SWAP DO  I LOAD  LOOP ;
\ LOADS screens n through n2.

: \   >IN @ 64 + -64 AND >IN ! ;  IMMEDIATE
\ comment to end of line.  For use in screens only.

: \\   1024 >IN ! ;  IMMEDIATE
\ stops interpreting or compiling screen immediately.

: \IF ( f )   0= IF  [COMPILE] \  THEN ;  IMMEDIATE
\ conditional interpretation or compilation.

: NEED ( - f)   32 ( ie blank) WORD FIND  SWAP DROP  0= ;
\ true if the following word is in the search order.
\ FORTH-83 Controlled Words

NEED  2* \IF  :  2*    DUP  + ;
NEED D2* \IF  : D2*   2DUP D+ ;

NEED HEX \IF  : HEX   16 BASE ! ;
NEED  C, \IF  : C, ( n )   HERE 1 ALLOT C! ;

NEED BL \IF  32 CONSTANT BL

NEED ERASE \IF  : ERASE ( a n)   00 FILL ;
NEED BLANK \IF  : BLANK ( a n)   BL FILL ;

NEED .R \IF  : .R ( n width)   >R DUP 0< R> D.R ;


\ DDJ Forth Column Controlled Words
NEED 2>R
\IF : 2>R   COMPILE SWAP COMPILE >R COMPILE >R ;  IMMEDIATE
NEED 2R>
\IF : 2R>   COMPILE R> COMPILE R> COMPILE SWAP ;  IMMEDIATE
NEED @EXECUTE \IF  : @EXECUTE   @ EXECUTE ;

NEED AGAIN
\IF  : AGAIN   0 [COMPILE] LITERAL [COMPILE] UNTIL ;  IMMEDIATE
NEED DLITERAL
DUP \IF  : DLITERAL  SWAP [COMPILE] LITERAL [COMPILE] LITERAL ;
    \IF   IMMEDIATE

NEED S>D  \IF  : S>D  ( n - d)    DUP 0< ;
NEED WITHIN   \IF  : WITHIN ( n n2 n3 - f)  OVER - >R - R> U< ;
NEED TRUE \IF  -1 CONSTANT TRUE
\ String primitives

: /STRING ( a n n2 - a+n2 n-n2)   ROT OVER +  ROT ROT - ;
\ truncates leftmost n chars of string.  n may be negative.

VARIABLE CTEMP

: CTO"" ( c - a 1)   CTEMP C!  CTEMP 1 ;
\ converts character to string.







\ SKIP and SCAN

: SKIP ( a l c - a2 l2)
\ returns shorter string from first position unequal to byte.
   >R  BEGIN  DUP
       WHILE  OVER C@ R@ - IF  R> DROP  EXIT  THEN  1 /STRING
       REPEAT   R> DROP ;

: SCAN ( a l byte - a2 l2)
\ returns shorter string from first position equal to byte.
   >R  BEGIN  DUP
       WHILE  OVER C@ R@ =  IF  R> DROP  EXIT  THEN  1 /STRING
       REPEAT   R> DROP ;



\ String compilation

: PLACE ( a n a2)   2DUP !  1+ SWAP CMOVE ;
\ moves string ( a n ) to be a packed string at a2.

: ASCII ( - c)   \ value of following character.
   BL WORD 1+ C@  STATE @   \ STATE-smart ASCII
   IF  [COMPILE] LITERAL  THEN ;  IMMEDIATE

: ,"   \ compiles following string as packed string at HERE
   ASCII " WORD COUNT  DUP >R  HERE PLACE  R> 1+ ALLOT  ALIGN ;





\ String literals

: (")   I> COUNT  2DUP + >I ;

: " ( - a n)   STATE @   \ string literal.
   IF  COMPILE (") ,"
   ELSE  ASCII " WORD COUNT >R  PAD I CMOVE  PAD R>  THEN ;
  IMMEDIATE








\ Number conversion operator
VARIABLE DPL  \ punctuation locator.

: VAL? ( a n - d 2 , n2 1 , 0)
\ string to number conversion primitive.  True if d is valid.
\ Returns d if number contains ",-./:"  and sets DPL = 0
\ Returns n if no punctuation present   and sets DPL = 0<
   PAD OVER -  SWAP OVER >R  CMOVE
   BL PAD C!  PAD DPL !  0 0 R>  DUP C@ ASCII - = DUP >R - 1-
   BEGIN  CONVERT  DUP C@  DUP ASCII : =
     SWAP ASCII , ASCII / 1+ WITHIN  OR
   WHILE  DUP DPL !  REPEAT  R> SWAP >R IF  DNEGATE  THEN
   PAD 1- DPL @ - DPL !  R> PAD = ( valid?)
   IF  DPL @ 0< IF DROP 1 ELSE 2 THEN  ELSE  2DROP 0  THEN ;


\ -TEXT and COMPARE

: -TEXT ( a n a2 - -1 , 0 , 1)
\ returns -1 if string a n < a2 n , 0 if equal, and 1 if >.
   OVER 0= IF  ROT 2DROP  EXIT  THEN
   SWAP 0 DO  OVER C@ OVER C@ - ( these chars <> ?)
            IF  UNDO  C@ SWAP C@ > 2* 1+  EXIT  THEN  1 1 D+
          LOOP  2DROP 0 ;

: COMPARE  ( a n a2 n2 - -1 , 0 , 1)
\ returns -1 if a n < a2 n2 , 0 if equal, and 1 if >.
   ROT  2DUP ( lengths ) 2>R  MIN SWAP  -TEXT  DUP
   IF    2R> 2DROP
   ELSE  DROP  2R> 2DUP = ( lengths = ?)
       IF  2DROP 0  ELSE  > 2* 1+  THEN
   THEN ;
\ IN

: -MATCH ( a n a2 n2 - ???? -1 , offset 0)
\ returns the position of string a2 n2 in (a n).
\ Offset is zero if ( a n ) is found in first char position.
\ Returns true with invalid offset if ( a n ) isn't in a2 n2.
   2SWAP  2 PICK DUP ( len1 ) >R  OVER SWAP -  DUP 0< R> 0= OR
   IF  2DROP 2DROP  TRUE EXIT  THEN
   0 TRUE ( index match? )  ROT 1+ 0
   DO  DROP ( index ) >R
     2OVER 2OVER DROP  -TEXT 0=  ( equal? )
     IF  R> 0 LEAVE  THEN  1 /STRING  R> 1+  TRUE
   LOOP
   2>R  2DROP 2DROP  2R> ;


\ Useful string operators

: VAL ( a n - d f)   VAL?  DUP 3 < AND
\ converts string to double number.  True if number is valid.
   DUP IF  1 = IF  S>D  THEN  TRUE EXIT  THEN  DUP DUP ;

: EVAL ( a n )
\ evaluates ("text interprets") a string.
   DUP >R  TIB SWAP CMOVE  R@ #TIB !
   0 >IN ! 0 BLK !  INTERPRET  R> >IN ! ;